home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / CaptureScr2152985232009.psc / AVItoGIF 1.0 / cDIB.cls < prev   
Text File  |  2004-06-28  |  19KB  |  551 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cDIB"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '================================================
  15. ' Class:         cDIB.cls
  16. ' Author:        Carles P.V.
  17. ' Dependencies:  None
  18. ' Last revision: 2003.05.25
  19. '================================================
  20.  
  21. Option Explicit
  22.  
  23. '-- API:
  24.  
  25. Private Type BITMAPINFOHEADER
  26.     biSize          As Long
  27.     biWidth         As Long
  28.     biHeight        As Long
  29.     biPlanes        As Integer
  30.     biBitCount      As Integer
  31.     biCompression   As Long
  32.     biSizeImage     As Long
  33.     biXPelsPerMeter As Long
  34.     biYPelsPerMeter As Long
  35.     biClrUsed       As Long
  36.     biClrImportant  As Long
  37. End Type
  38.  
  39. Private Type BITMAP
  40.     bmType       As Long
  41.     bmWidth      As Long
  42.     bmHeight     As Long
  43.     bmWidthBytes As Long
  44.     bmPlanes     As Integer
  45.     bmBitsPixel  As Integer
  46.     bmBits       As Long
  47. End Type
  48.  
  49. Private Type BITMAPINFO_001
  50.     bmiHeader       As BITMAPINFOHEADER
  51.     bmiColors(7)    As Byte
  52. End Type
  53.  
  54. Private Type BITMAPINFO_004
  55.     bmiHeader       As BITMAPINFOHEADER
  56.     bmiColors(63)   As Byte
  57. End Type
  58.  
  59. Private Type BITMAPINFO_008
  60.     bmiHeader       As BITMAPINFOHEADER
  61.     bmiColors(1023) As Byte
  62. End Type
  63.  
  64. Private Type BITMAPINFO_RGB
  65.     bmiHeader       As BITMAPINFOHEADER
  66. End Type
  67.  
  68. Private Type GUID
  69.     Data1 As Long
  70.     Data2 As Integer
  71.     Data3 As Integer
  72.     Data4(7) As Byte
  73. End Type
  74.  
  75. Private Type PICTDESC
  76.     Size As Long
  77.     Type As Long
  78.     hBmp As Long
  79.     hPal As Long
  80. End Type
  81.  
  82. Private Type RECT2
  83.     x1 As Long
  84.     y1 As Long
  85.     x2 As Long
  86.     y2 As Long
  87. End Type
  88.  
  89. Private Const DIB_RGB_COLORS      As Long = 0
  90. Private Const COLORONCOLOR        As Long = 3
  91. Private Const OBJ_BITMAP          As Long = 7
  92. Private Const LR_LOADFROMFILE     As Long = &H10
  93. Private Const IMAGE_BITMAP        As Long = 0
  94. Private Const LR_CREATEDIBSECTION As Long = &H2000
  95.  
  96. Private Declare Function CreateDIBSection_001 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, lpBitsInfo As BITMAPINFO_001, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
  97. Private Declare Function CreateDIBSection_004 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, lpBitsInfo As BITMAPINFO_004, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
  98. Private Declare Function CreateDIBSection_008 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, lpBitsInfo As BITMAPINFO_008, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
  99. Private Declare Function CreateDIBSection_RGB Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, lpBitsInfo As BITMAPINFO_RGB, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
  100. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
  101.  
  102. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  103. Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
  104. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  105. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  106. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  107. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  108. Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
  109. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  110. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  111. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  112. Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long
  113. Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long
  114. Private Declare Function BitBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  115. Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  116. Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
  117. Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hDC As Long) As Long
  118. Private Declare Function SetRect Lib "user32" (lpRect As RECT2, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
  119. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT2, ByVal hBrush As Long) As Long
  120. Private Declare Function OleTranslateColor Lib "olepro32" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, ColorRef As Long) As Long
  121. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  122. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal Length As Long)
  123.  
  124. '//
  125.  
  126. '-- Public Enums.:
  127. Public Enum dibBPPCts
  128.     [01_bpp] = 1
  129.     [04_bpp] = 4
  130.     [08_bpp] = 8
  131.     [16_bpp] = 16
  132.     [24_bpp] = 24
  133.     [32_bpp] = 32
  134. End Enum
  135.  
  136. '-- Property Variables:
  137. Private m_hDC              As Long
  138. Private m_hDIB             As Long
  139. Private m_lpBits           As Long
  140. Private m_Width            As Long
  141. Private m_Height           As Long
  142. Private m_BPP              As dibBPPCts
  143. Private m_BytesPerScanline As Long
  144. Private m_Size             As Long
  145.  
  146. '-- Private Variables:
  147. Private m_tBIH             As BITMAPINFOHEADER
  148. Private m_hOldDIB          As Long
  149.  
  150.  
  151.  
  152. '========================================================================================
  153. ' Class
  154. '========================================================================================
  155.  
  156. Private Sub Class_Terminate()
  157.     '-- Destroy current DIB
  158.     Destroy
  159. End Sub
  160.  
  161. '========================================================================================
  162. ' Methods
  163. '========================================================================================
  164.  
  165. Public Function Create(ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal Newbpp As dibBPPCts) As Boolean
  166.     
  167.   Dim BI_001 As BITMAPINFO_001
  168.   Dim BI_004 As BITMAPINFO_004
  169.   Dim BI_008 As BITMAPINFO_008
  170.   Dim BI_RGB As BITMAPINFO_RGB
  171.   
  172.     '-- Destroy previous
  173.     Destroy
  174.     
  175.     '-- Define DIB header
  176.     With m_tBIH
  177.         .biSize = Len(m_tBIH)
  178.         .biPlanes = 1
  179.         .biBitCount = Newbpp
  180.         .biWidth = NewWidth
  181.         .biHeight = -NewHeight
  182.     End With
  183.     Select Case Newbpp
  184.         Case [01_bpp]: BI_001.bmiHeader = m_tBIH
  185.         Case [04_bpp]: BI_004.bmiHeader = m_tBIH
  186.         Case [08_bpp]: BI_008.bmiHeader = m_tBIH
  187.         Case Else:     BI_RGB.bmiHeader = m_tBIH
  188.     End Select
  189.     
  190.     '-- Set private props.
  191.     m_Width = NewWidth
  192.     m_Height = NewHeight
  193.     m_BPP = Newbpp
  194.     m_BytesPerScanline = ((m_Width * Newbpp + 31) \ 32) * 4
  195.     m_Size = m_BytesPerScanline * m_Height
  196.     
  197.     '-- Create DIB and select into a DC
  198.     m_hDC = CreateCompatibleDC(0)
  199.     If (m_hDC <> 0) Then
  200.         Select Case Newbpp
  201.             Case [01_bpp]: m_hDIB = CreateDIBSection_001(m_hDC, BI_001, DIB_RGB_COLORS, m_lpBits, 0, 0)
  202.             Case [04_bpp]: m_hDIB = CreateDIBSection_004(m_hDC, BI_004, DIB_RGB_COLORS, m_lpBits, 0, 0)
  203.             Case [08_bpp]: m_hDIB = CreateDIBSection_008(m_hDC, BI_008, DIB_RGB_COLORS, m_lpBits, 0, 0)
  204.             Case Else:     m_hDIB = CreateDIBSection_RGB(m_hDC, BI_RGB, DIB_RGB_COLORS, m_lpBits, 0, 0)
  205.         End Select
  206.         If (m_hDIB <> 0) Then
  207.             m_hOldDIB = SelectObject(m_hDC, m_hDIB)
  208.           Else
  209.             Destroy
  210.         End If
  211.     End If
  212.     
  213.     '-- Success
  214.     Create = (m_hDIB <> 0)
  215. End Function
  216.  
  217. Public Function CreateFromStdPicture(Image As StdPicture, Optional ByVal Force32bpp As Boolean = 0) As Byte
  218.  
  219.   Dim tBI      As BITMAP
  220.   Dim lhDC     As Long
  221.   Dim lhOldBmp As Long
  222.   Dim aPal()   As Byte
  223.     
  224.     If (Not Image Is Nothing) Then
  225.         
  226.         '-- Check object type
  227.         If (GetObjectType(Image) = OBJ_BITMAP) Then
  228.         
  229.             '-- Get object info
  230.             GetObject Image, Len(tBI), tBI
  231.             
  232.             '-- Create DIB
  233.             If (Create(tBI.bmWidth, tBI.bmHeight, IIf(Force32bpp, [32_bpp], tBI.bmBitsPixel))) Then
  234.                 lhDC = CreateCompatibleDC(m_hDC)
  235.                 If (lhDC <> 0) Then
  236.                     lhOldBmp = SelectObject(lhDC, Image.handle)
  237.                     
  238.                     With tBI
  239.                         '-- Load palette [?]
  240.                         If (.bmBitsPixel <= 8 And Not Force32bpp) Then
  241.                             ReDim aPal(4 * (2 ^ .bmBitsPixel) - 1)
  242.                             GetDIBColorTable lhDC, 0, 2 ^ .bmBitsPixel, aPal(0)
  243.                             SetDIBColorTable m_hDC, 0, 2 ^ .bmBitsPixel, aPal(0)
  244.                         End If
  245.                         '-- Load bits
  246.                         BitBlt m_hDC, 0, 0, .bmWidth, .bmHeight, lhDC, 0, 0, vbSrcCopy
  247.                     End With
  248.                     
  249.                     '-- Destroy temp. DC
  250.                     SelectObject lhDC, lhOldBmp
  251.                     DeleteDC lhDC
  252.                     
  253.                     '-- Success
  254.                     CreateFromStdPicture = tBI.bmBitsPixel
  255.                 End If
  256.             End If
  257.         End If
  258.     End If
  259. End Function
  260.  
  261. Public Function CreateFromBitmapFile(ByVal Filename As String) As Byte
  262. '-- Use this function instead of CreateFromStdPicture (getting Image from VB LoadPicture) if
  263. '   you want to preserve original image format (color depth). LoadPicture 'dithers' to current
  264. '   screen color depth.
  265.  
  266.   Dim tBI As BITMAP
  267.     
  268.     '-- File exists [?]
  269.     If (FileLen(Filename)) Then
  270.     
  271.         '-- Destroy previous
  272.         Destroy
  273.  
  274.         '-- Create DIB and select into a DC
  275.         m_hDC = CreateCompatibleDC(0)
  276.         If (m_hDC <> 0) Then
  277.             m_hDIB = LoadImage(App.hInstance, Filename, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
  278.             If (m_hDIB <> 0) Then
  279.                 m_hOldDIB = SelectObject(m_hDC, m_hDIB)
  280.               Else
  281.                 Destroy
  282.             End If
  283.         End If
  284.         
  285.         '-- Get DIB props.:
  286.         If (m_hDIB <> 0) Then
  287.             '-- Get object
  288.             GetObject m_hDIB, Len(tBI), tBI
  289.             '-- Get props.:
  290.             With tBI
  291.                 m_Width = .bmWidth
  292.                 m_Height = .bmHeight
  293.                 m_BPP = .bmBitsPixel
  294.                 m_BytesPerScanline = ((m_Width * m_BPP + 31) \ 32) * 4
  295.                 m_Size = m_BytesPerScanline * m_Height
  296.                 '-- Bits pointer
  297.                 m_lpBits = .bmBits
  298.             End With
  299.             
  300.             '-- Success
  301.             CreateFromBitmapFile = m_BPP
  302.         End If
  303.     End If
  304. End Function
  305.  
  306. Public Sub CloneTo(oDIB As cDIB)
  307.     
  308.   Dim aPal() As Byte
  309.     
  310.     '-- Create dest. DIB
  311.     oDIB.Create m_Width, m_Height, m_BPP
  312.     '-- Palette [?]
  313.     If (m_BPP <= 8) Then
  314.         GetPalette aPal()
  315.         oDIB.SetPalette aPal()
  316.     End If
  317.     '-- Copy bits
  318.     CopyMemory ByVal oDIB.lpBits, ByVal m_lpBits, m_Size
  319. End Sub
  320.  
  321. Public Sub Destroy()
  322.  
  323.     '-- Destroy DIB
  324.     If (m_hDC <> 0) Then
  325.         If (m_hDIB <> 0) Then
  326.             SelectObject m_hDC, m_hOldDIB
  327.             DeleteObject m_hDIB
  328.         End If
  329.         DeleteDC m_hDC
  330.     End If
  331.     
  332.     '-- Reset DIB vars.
  333.     m_hDC = 0
  334.     m_hDIB = 0
  335.     m_hOldDIB = 0
  336.     m_lpBits = 0
  337.     
  338.     '-- Reset DIB props.
  339.     m_Width = 0
  340.     m_Height = 0
  341.     m_BPP = 0
  342.     m_BytesPerScanline = 0
  343.     m_Size = 0
  344. End Sub
  345.  
  346. '//
  347.  
  348. Public Function LoadBlt(ByVal hSrcDC As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal nWidth As Long, Optional ByVal nHeight As Long) As Long
  349.     
  350.     If (m_hDIB <> 0) Then
  351.         
  352.         '-- Check bounds
  353.         If (nWidth <= 0) Then nWidth = m_Width
  354.         If (nHeight <= 0) Then nHeight = m_Height
  355.         
  356.         '-- Paint bits (*)
  357.         LoadBlt = BitBlt(m_hDC, 0, 0, nWidth, nHeight, hSrcDC, x, y, vbSrcCopy)
  358.     End If
  359.     
  360. ' (*) 32bpp format: Alpha will be lost.
  361. '     So, use CloneTo or CopyMemory from/to bits pointers
  362. End Function
  363.   
  364. Public Function Stretch(ByVal hDstDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal xSrc As Long, Optional ByVal ySrc As Long, Optional ByVal nSrcWidth As Long, Optional ByVal nSrcHeight As Long, Optional ByVal lROP As RasterOpConstants = vbSrcCopy) As Long
  365.   
  366.   Dim lMode As Long
  367.     
  368.     If (m_hDIB <> 0) Then
  369.         
  370.         '-- Check bounds
  371.         If (nSrcWidth <= 0) Then nSrcWidth = m_Width
  372.         If (nSrcHeight <= 0) Then nSrcHeight = m_Height
  373.         
  374.         '-- BitBlt/StretchBlt
  375.         lMode = GetStretchBltMode(hDstDC)
  376.         SetStretchBltMode hDstDC, COLORONCOLOR
  377.         Stretch = StretchBlt(hDstDC, x, y, nWidth, nHeight, m_hDC, xSrc, ySrc, nSrcWidth, nSrcHeight, lROP)
  378.         SetStretchBltMode hDstDC, lMode
  379.     End If
  380. End Function
  381.  
  382. Public Sub Cls(Optional ByVal BackColor As Long = &H0)
  383.   
  384.   Dim tRect  As RECT2
  385.   Dim lColor As Long
  386.   Dim hBrush As Long
  387.    
  388.     '-- Clear background (*)
  389.     If (m_hDIB <> 0) Then
  390.         SetRect tRect, 0, 0, m_Width, m_Height
  391.         OleTranslateColor BackColor, 0, lColor
  392.         hBrush = CreateSolidBrush(lColor)
  393.         FillRect m_hDC, tRect, hBrush
  394.         DeleteObject hBrush
  395.     End If
  396.     
  397. ' (*) Paletted formats: Windows will match given color to
  398. '     the closest DIB palette color.
  399. End Sub
  400.  
  401. '//
  402.  
  403. Public Sub SetPalette(Palette() As Byte)
  404.     
  405.     '-- Use source array bounds
  406.     If (m_hDIB <> 0 And m_BPP <= [08_bpp]) Then
  407.         SetDIBColorTable m_hDC, 0, (UBound(Palette) + 1) \ 4, Palette(0)
  408.     End If
  409. End Sub
  410.  
  411. Public Sub GetPalette(Palette() As Byte)
  412.     
  413.     '-- Use current bpp as target array bounds
  414.     If (m_hDIB <> 0 And m_BPP <= [08_bpp]) Then
  415.         ReDim Palette(4 * (2 ^ m_BPP) - 1)
  416.         GetDIBColorTable m_hDC, 0, 2 ^ m_BPP, Palette(0)
  417.     End If
  418. End Sub
  419.  
  420. '//
  421.  
  422. Public Sub Resize(ByVal NewWidth As Long, ByVal NewHeight As Long, Optional ByVal StretchDIB As Boolean = -1)
  423.  
  424.   Dim oDIB   As New cDIB
  425.   Dim aPal() As Byte
  426.     
  427.     '-- Create resized DIB (temp.)
  428.     oDIB.Create NewWidth, NewHeight, m_BPP
  429.     '-- Palette [?]
  430.     If (m_BPP <= 8) Then
  431.         GetPalette aPal()
  432.         oDIB.SetPalette aPal()
  433.     End If
  434.     '-- Set bits
  435.     If (StretchDIB) Then
  436.         Stretch oDIB.hDC, 0, 0, NewWidth, NewHeight
  437.       Else
  438.         Stretch oDIB.hDC, 0, 0, m_Width, m_Height
  439.     End If
  440.     
  441.     '-- Create new and load bits
  442.     Create NewWidth, NewHeight, m_BPP
  443.     If (m_BPP <= 8) Then
  444.         SetPalette aPal()
  445.     End If
  446.     LoadBlt oDIB.hDC
  447. End Sub
  448.  
  449. Public Sub GetBestFitInfo(ByVal DstW As Long, ByVal DstH As Long, bfx As Long, bfy As Long, bfW As Long, bfH As Long, Optional ByVal StretchFit As Boolean = 0)
  450.   
  451.   Dim cW As Single
  452.   Dim cH As Single
  453.     
  454.     If (m_hDIB <> 0) Then
  455.         '-- Get best fit dimensions
  456.         If ((m_Width > DstW Or m_Height > DstH) Or StretchFit) Then
  457.             cW = DstW / m_Width
  458.             cH = DstH / m_Height
  459.             If (cW < cH) Then
  460.                 bfW = DstW
  461.                 bfH = m_Height * cW
  462.               Else
  463.                 bfH = DstH
  464.                 bfW = m_Width * cH
  465.             End If
  466.           Else
  467.             bfW = m_Width
  468.             bfH = m_Height
  469.         End If
  470.         '-- Get best fit offsets
  471.         bfx = (DstW - bfW) \ 2
  472.         bfy = (DstH - bfH) \ 2
  473.     End If
  474. End Sub
  475.  
  476. '========================================================================================
  477. ' Properties
  478. '========================================================================================
  479.  
  480. Public Property Get hDC() As Long
  481.     hDC = m_hDC
  482. End Property
  483.  
  484. Public Property Get hDIB() As Long
  485.     hDIB = m_hDIB
  486. End Property
  487.  
  488. Public Property Get lpBits() As Long
  489.     lpBits = m_lpBits
  490. End Property
  491.  
  492. Public Property Get Width() As Long
  493.     Width = m_Width
  494. End Property
  495.  
  496. Public Property Get Height() As Long
  497.     Height = m_Height
  498. End Property
  499.  
  500. Public Property Get BPP() As dibBPPCts
  501.     BPP = m_BPP
  502. End Property
  503.  
  504. Public Property Get BytesPerScanline() As Long
  505.     BytesPerScanline = m_BytesPerScanline
  506. End Property
  507.  
  508. Public Property Get Size() As Long
  509.     Size = m_Size
  510. End Property
  511.  
  512. Property Get Image() As StdPicture
  513. ' by Vlad Vissoultchev.
  514. ' Returned Image color depth = current screen color depth.
  515.     
  516.   Dim hSrcDC        As Long
  517.   Dim hDC           As Long
  518.   Dim hBmp          As Long
  519.   Dim hOldBmp       As Long
  520.   Dim lpPictDesc    As PICTDESC
  521.   Dim IID_IDispatch As GUID
  522.  
  523.     '-- Create temp. bitmap
  524.     hSrcDC = GetDC(0)
  525.     hDC = CreateCompatibleDC(hSrcDC)
  526.     hBmp = CreateCompatibleBitmap(hSrcDC, m_Width, m_Height)
  527.     hOldBmp = SelectObject(hDC, hBmp)
  528.     Call ReleaseDC(0, hSrcDC)
  529.     '-- Paint from DIB
  530.     Stretch hDC, 0, 0, m_Width, m_Height
  531.     '-- Cleanup
  532.     Call SelectObject(hDC, hOldBmp)
  533.     Call DeleteDC(hDC)
  534.     
  535.     '-- Fill image info
  536.     With lpPictDesc
  537.         .Size = Len(lpPictDesc)
  538.         .Type = vbPicTypeBitmap
  539.         .hBmp = hBmp
  540.         .hPal = 0
  541.     End With
  542.     '-- Fill GUID info
  543.     With IID_IDispatch
  544.         .Data1 = &H20400
  545.         .Data4(0) = &HC0
  546.         .Data4(7) = &H46
  547.     End With
  548.     '-- Create picture from bitmap handle
  549.     Call OleCreatePictureIndirect(lpPictDesc, IID_IDispatch, 1, Image)
  550. End Property
  551.